home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / SHDK_1 / SHERRMSG.PAS < prev    next >
Pascal/Delphi Source File  |  1992-03-23  |  10KB  |  322 lines
  1. {$V-}
  2. unit  ShErrMsg;
  3. {
  4.                                 ShErrMsg
  5.  
  6.                          An Exit Procedure Unit
  7.  
  8.                                    by
  9.  
  10.                               Bill Madison
  11.  
  12.                    W. G. Madison and Associates, Ltd.
  13.                           13819 Shavano Downs
  14.                             P.O. Box 780956
  15.                        San Antonio, TX 78278-0956
  16.                              (512)492-2777
  17.                              CIS 73240,342
  18.  
  19.                   Copyright 1991 Madison & Associates
  20.                           All Rights Reserved
  21.  
  22.         This file may  be used and distributed  only in accord-
  23.         ance with the provisions described on the title page of
  24.                   the accompanying documentation file
  25.                               SKYHAWK.DOC
  26. }
  27.  
  28. interface
  29.  
  30. procedure CheckOn;
  31. procedure CheckOff;
  32. {These two procedures turn error checking on and off. If off, control
  33.  is passed directly to the TP exit procedure chain. The default state
  34.  is On.}
  35.  
  36. procedure RunErrorMsg(Code : integer; Msg : string);
  37. {This procedure simulates the effect of a runtime error, but unlike the
  38.  Tp RunError procedure, it uses the entire CODE instead of only the low
  39.  byte. Also unlike Tp RunError and system exit procedures, RunErrorMsg
  40.  reports the error address in normalized form (the offset is always <=
  41.  $F). If, however, a program using ShErrMsg is run from a batch file and
  42.  ErrorLevel is checked, only the low byte will be reported. This is a
  43.  restriction of DOS.}
  44.  
  45. procedure HaltMsg(Code : word; Msg : string); {This procedure simulates
  46.  the effect of the System.Halt procedure, but unlike System.Halt, it uses
  47.  the entire CODE instead of only the low byte. Also unlike Tp Halt and
  48.  system exit procedures, HaltMsg reports the error address in normalized
  49.  form (the offset is always <= $F). If, however, a program using ShErrMsg
  50.  is run from a batch file and ErrorLevel is checked, only the low byte
  51.  will be reported. This is a restriction of DOS.}
  52.  
  53. implementation
  54.  
  55. {The string W and the array of strings M together contain, in coded
  56.  form, all of the built-in runtime error messages. In the array M, an
  57.  "@" is a functional escape character. The byte value of the following
  58.  character is an index into string W. The runtime error message actually
  59.  displayed is constructed by locating the appropriate string in M,
  60.  displaying that string until an "@" is encountered, using the byte
  61.  value of the character following "@" as an index into W, and displaying
  62.  characters from W until a blank is encountered.
  63.  
  64.  While this may seem unnecessarily complex, it provides considerable
  65.  space saving in any programs using ShErrMsg.
  66.  
  67.  It also suggests that W and M be modified only with extreme caution.}
  68.  
  69.  
  70. const
  71.   W : string = 'Cannot '+
  72.                'Device '+
  73.                'Disk '+
  74.                'File '+
  75.                'Floating '+
  76.                'Invalid '+
  77.                'Overlay '+
  78.                'Unknown '+
  79.                'access '+
  80.                'been '+
  81.                'data '+
  82.                'drive '+
  83.                'error '+
  84.                'fault '+
  85.                'file '+
  86.                'files '+
  87.                'for '+
  88.                'format '+
  89.                'found '+
  90.                'has '+
  91.                'input '+
  92.                'memory '+
  93.                'not '+
  94.                'number '+
  95.                'open '+
  96.                'operation '+
  97.                'or '+
  98.                'overflow '+
  99.                'point '+
  100.                'read '+
  101.                'write ';
  102.  
  103. type
  104.   Mstring = string[41];
  105.  
  106. const
  107.   M : array[1..49] of Mstring =
  108.                 ('1 - @" DOS function @Ä',
  109.                  '2 - @ @ @s',
  110.                  '3 - Path @ @s',
  111.                  '4 - Too many @ò @b',
  112.                  '5 - @ @: denied',
  113.                  '6 - @" @] handle - Handle @y @A trashed',
  114.                  '7 - Memory control blocks destroyed',
  115.                  '8 - Insufficient @â',
  116.                  '9 - @" @â block address',
  117.                  '10 - @" environment',
  118.                  '11 - @" @l',
  119.                  '12 - @" @] @: code',
  120.                  '13 - @" @F',
  121.                  '14 - Unused (reserved)',
  122.                  '15 - @" @K @Ä',
  123.                  '16 - @ remove current directory',
  124.                  '17 - @ rename across drives',
  125.                  '18 - No more @b',
  126.                  '100 -  @ @╢ @Q',
  127.                  '101 - @ @╗ @Q - @ probably full',
  128.                  '102 - @ @ assigned',
  129.                  '103 - @ @ @ò',
  130.                  '104 - @ @ @ò @h @}',
  131.                  '105 - @ @ @ò @h output',
  132.                  '106 - @" numeric @l @í @}',
  133.                  '150 - @ @ @╗ protected',
  134.                  '151 - @2 unit',
  135.                  '152 - Drive @ ready',
  136.                  '153 - @2 command',
  137.                  '154 - CRC @Q @ @F',
  138.                  '155 - Bad @K request structure length',
  139.                  '156 - @ seek @Q',
  140.                  '157 - @2 media type',
  141.                  '158 - Sector @ @s',
  142.                  '159 - Printer out of paper',
  143.                  '160 - @ @╗ @W',
  144.                  '161 - @ @╢ @W',
  145.                  '162 - Hardware failure',
  146.                  '200 - Division by zero',
  147.                  '201 - Range check @Q',
  148.                  '202 - Stack @º @Q',
  149.                  '203 - Heap @º @Q',
  150.                  '204 - @" pointer @Ü',
  151.                  '205 - @ @░ @º',
  152.                  '206 - @ @░ underflow',
  153.                  '207 - @" floating @░ @Ü @T 80x87 stack @º',
  154.                  '208 - @* Manager @ installed',
  155.                  '209 - @* @] @╢ @Q',
  156.                  '210 - Object @ initialized');
  157.  
  158. procedure GetNext(var S1, S2  : string);
  159.   var
  160.     T1  : byte;
  161.   begin
  162.     while (S1[1] = ' ') and (Length(S1) > 0) do
  163.       Delete(S1,1,1);
  164.     T1 := Pos(' ',S1);
  165.     if (T1 = 0) then begin
  166.       S2 := S1;
  167.       S1 := '';
  168.       exit;
  169.       end;
  170.     S2 := Copy(S1,1,T1-1);
  171.     Delete(S1,1,T1);
  172.     end;
  173.  
  174. function DisplayMessages(Idx  : word) : string;
  175. {Given an error code "Idx", an error message will be returned. If
  176.  Idx is not recognized, an empty string will be returned.}
  177.   var
  178.     W1  : word;
  179.     IdxS: string[5];
  180.     T1  : byte;
  181.     Msg,
  182.     S1  : string;
  183.     Mx  : Mstring;
  184.   begin
  185.     W1 := 1;
  186.     str(Idx, IdxS);
  187.     IdxS := IdxS + ' ';
  188.     while (Pos(IdxS, M[W1]) <> 1) and (W1 < 49) do begin
  189.       inc(W1);
  190.       end;
  191.     if Pos(IdxS, M[W1]) <> 1 then begin
  192.       DisplayMessages := IdxS + ' Unknown error code';
  193.       exit;
  194.       end;
  195.     Msg := '';
  196.     Mx := M[W1];
  197.     repeat
  198.       GetNext(Mx, S1);
  199.       if S1 <> '' then
  200.         if S1[1] <> '@' then
  201.           Msg := Msg + S1 + ' '
  202.         else begin
  203.           T1 := byte(S1[2]);
  204.           repeat
  205.             Msg := Msg + W[T1];
  206.             inc(T1);
  207.             until W[T1-1] = ' ';
  208.           end;
  209.       until S1 = '';
  210.     DisplayMessages := Msg;
  211.     end; {DisplayMessages}
  212.  
  213. const
  214.   Check4Errors  : boolean = true;
  215.  
  216. procedure CheckOn;
  217.   begin
  218.     Check4Errors := true;
  219.     end;
  220.  
  221. procedure CheckOff;
  222.   begin
  223.     Check4Errors := false;
  224.     end;
  225.  
  226. var
  227.   UsrAddr,
  228.   ExitSave  : pointer;
  229.   UsrCode   : integer;
  230.   UsrMsg    : string[80];
  231.   W1, W2    : word;
  232.  
  233. procedure RunErrorMsg(Code : integer; Msg : string);
  234. {This procedure simulates the effect of a runtime error, but unlike the
  235.  Tp RunError procedure, it uses the entire CODE instead of only the low
  236.  byte.}
  237.   begin
  238.     Inline(
  239.       $36/$8B/$46/$02/       {ss: mov  ax, [bp+2]}
  240.       $A3/>w1/               {    mov  [>w1], ax}
  241.       $36/$8B/$46/$04/       {ss: mov  ax, [bp+4]}
  242.       $A3/>w2);              {    mov  [>w2], ax}
  243.  
  244.     UsrCode := Code;
  245.     UsrMsg  := Msg;
  246.     UsrAddr := ptr(W2, W1);
  247.     System.RunError(Code);
  248.     end;
  249.  
  250. procedure HaltMsg(Code : word; Msg : string);
  251. {This procedure simulates the effect of the System.Halt procedure, but
  252.  unlike System.Halt, it uses the entire CODE instead of only the low
  253.  byte.}
  254.   begin
  255.     UsrCode := Code;
  256.     UsrMsg := Msg;
  257.     System.Halt(Code);
  258.     end;
  259.  
  260. {$F+}
  261. procedure ShErr;
  262.   function HexW(W : Word) : string;
  263.     {-Return hex string for word}
  264.     const
  265.       Digits : array[0..$F] of Char = '0123456789ABCDEF';
  266.     begin
  267.       HexW[0] := #4;
  268.       HexW[1] := Digits[hi(W) shr 4];
  269.       HexW[2] := Digits[hi(W) and $F];
  270.       HexW[3] := Digits[lo(W) shr 4];
  271.       HexW[4] := Digits[lo(W) and $F];
  272.       end;
  273.   function HexPtr(P : Pointer) : string;
  274.     {-Return hex string for pointer}
  275.     var
  276.       LP  : LongInt;
  277.     begin
  278.       LP := (Seg(P^) shl 4) + Ofs(P^);
  279.       HexPtr := HexW(LP shr 4) + ':' + HexW(LP mod $10);
  280.       end;
  281.  
  282.   begin {ShErr}
  283.     ExitProc := ExitSave;
  284.  
  285.     {Process a normal termination, including Halt(0).}
  286.     if (ExitCode = 0) and (ErrorAddr = nil) then exit;
  287.  
  288.     {Process if error messages not desired.}
  289.     if not Check4Errors then exit;
  290.  
  291.     {Process for error messages.}
  292.     if ErrorAddr = nil then begin           {It was a HALT}
  293.       if UsrMsg = '' then    {Display message if there is one}
  294.         exit                 {otherwise, just exit}
  295.       else begin             
  296.         ExitCode := UsrCode;
  297.         WriteLn(^M^J'ErrorLevel ',UsrCode);
  298.         WriteLn('     ',UsrMsg);
  299.         exit;
  300.         end; {else}
  301.       end {if ErrorAddr = nil}
  302.     else if UsrMsg = '' then begin
  303.                                             {Runtime error}
  304.       WriteLn(^M^J^G'Runtime error '+DisplayMessages(ExitCode));
  305.       WriteLn('     Error at '+HexPtr(ErrorAddr));
  306.       end {if HexPtr(ErrorAddr) <> HexPtr(UsrAddr)}
  307.     else begin
  308.       WriteLn(^M^J^G'Runtime error ', UsrCode, ' at ', HexPtr(UsrAddr));
  309.       WriteLn('':5, UsrMsg);
  310.       end;
  311.     ErrorAddr := nil;
  312.     end; {ShErr}
  313. {$F-}
  314.  
  315. begin
  316.   ExitSave := ExitProc;
  317.   ExitProc := @ShErr;
  318.   UsrCode := 0;
  319.   UsrAddr := nil;
  320.   UsrMsg := '';
  321.   end.
  322.